第一集影片底加 (ctrl + click)
善用商業數據分析的工具和技巧,光靠一份最簡單的交易紀錄(只有顧客ID、交易日期和交易金額三個欄位),我們就可以做一系列很深入、很有價值的顧客價值分析和行銷策略規劃,包括:
從這一些分析我們可以看到公司主要的營收和獲利的重要來源,我們也可以看到這一些產生獲利的群組是不是有成長或者衰退的趨勢;據此我們可以設定行銷的重點,決定行銷的策略,和規劃行銷的工具。除了上述的敘述統計、集群分析、和資料視覺化之外,我們還可以利用這些簡單的交易紀錄:
利用這一些預測我們就可以進行全面客製化的:
Z = read_csv("data/ta_feng_all_months_merged.csv") %>%
data.frame %>% setNames(c(
"date","cust","age","area","cat","prod","qty","cost","price"))Rows: 817741 Columns: 9
-- Column specification --------------------------------------------------------
Delimiter: ","
chr (5): TRANSACTION_DT, CUSTOMER_ID, AGE_GROUP, PIN_CODE, PRODUCT_ID
dbl (4): PRODUCT_SUBCLASS, AMOUNT, ASSET, SALES_PRICE
i Use `spec()` to retrieve the full column specification for this data.
i Specify the column types or set `show_col_types = FALSE` to quiet this message.
nrow(Z)[1] 817741
summary(Z) date cust age area
Length:817741 Length:817741 Length:817741 Length:817741
Class :character Class :character Class :character Class :character
Mode :character Mode :character Mode :character Mode :character
cat prod qty cost
Min. :100101 Length:817741 Min. : 1.00 Min. : 0
1st Qu.:110106 Class :character 1st Qu.: 1.00 1st Qu.: 35
Median :130106 Mode :character Median : 1.00 Median : 62
Mean :284950 Mean : 1.38 Mean : 112
3rd Qu.:520314 3rd Qu.: 1.00 3rd Qu.: 112
Max. :780510 Max. :1200.00 Max. :432000
price
Min. : 1
1st Qu.: 42
Median : 76
Mean : 132
3rd Qu.: 132
Max. :444000
# date:交易資料、cust:顧客ID、age:年齡族群、area:區域代碼
# cat:產品子類、prod:產品代碼、qty:數量、cost:資產、price:銷售價格
# 將資料套進公式read_csv()讀資料
# 再以data.frame儲存類似 Excel 表格的變數類型
# 依據交易日期、顧客ID、顧客年齡、顧客居住地區、交易項目(總)數
# 交易項目(總)數、產品(總)件數、交易(總)金額、毛利為 data frame 的列命名。
# 找出項目比數=817741Z$date = as.Date(Z$date, format="%m/%d/%Y")
par(cex=0.8)
hist(Z$date,'weeks',freq=T,las=2, main="No. Transaction by Weeks")# las=2坐標軸刻度垂直於坐標軸。
# as.Date(Z$date, format="%m/%d/%Y")用來抓取月份、日、年。
# par()生成一個含有當前圖形參數設置的列表。cex=控制文字和繪圖符號的大小,一般大小的80%。
# 繪出直方圖,x軸=以週為單位,y軸=訂單數。main=各週訂單數。#年齡級層和郵遞區號
age.group = c("<25","25-29","30-34","35-39","40-44",
"45-49","50-54","55-59","60-64",">65")
Z$age = c(paste0("a",seq(24,69,5)),"a99")[match(Z$age,age.group,11)]
# match在第二個參數中返回其第一個參數的(第一個)匹配位置的向量
# 例: dict <- c('a', 'b', 'c', 'd', 'e')
# ref <- c('a', 'e', 'hello')
# match(ref, dict, 15) 答: 1,5,15
# a99 無年齡資料的(不在範圍裡)
Z$area = paste0("z",Z$area)Fig-2:郵遞區號
par(mfrow=c(1,2),cex=0.7)
table(Z$age, useNA='ifany') %>% barplot(main="Age Groups", las=2)
table(Z$area,useNA='ifany') %>% barplot(main="Areas", las=2)# Quantile of Variables
sapply(Z[,7:9], quantile, prob=c(.99, .999, .9995)) #分位數 qty cost price
99% 6 858.0 1014.0
99.9% 14 2722.0 3135.8
99.95% 24 3799.3 3999.0
# Remove Outliers
Z = subset(Z, qty<=24 & cost<=3800 & price<=4000)
nrow(Z) # 原817741 後817182 [1] 817182
把每一天、每一為顧客的交易項目彙總為一張訂單
Z$tid = group_indices(Z, date, cust) # same customer same dayWarning: The `...` argument of `group_indices()` is deprecated as of dplyr 1.0.0.
Please `group_by()` first
This warning is displayed once every 8 hours.
Call `lifecycle::last_lifecycle_warnings()` to see where this warning was generated.
# group_indices 是根據date和cust的類別來分群 將兩個變數都相同的分在同一群
# 這邊是另外在Z資料集新增一個變數 將函式回傳的值存到tid
# 因為是根據日期跟顧客分群,所以同一個顧客同一天的tid 會相同
# 跟 group_by 相反 一個index一個實際的分組
########################################################################
# 817182
# 將Z資料框中,根據天數(date)跟顧客(cust)兩個欄位產生Index,叫做tid(每個組合給他一個編號)# No. cust, cat, prod, tid
sapply(Z[c("cust","cat","prod","tid")], n_distinct) cust cat prod tid
32256 2007 23789 119422
# n_distinct() 計算明顯不同的個體數目(計算列中唯一出現的次數)
# 一筆交易得到多個產品 <--> 那些產品共用一筆交易(tid)
# n_distinct(Z$cust)
# 顧客數 32256XX = Z %>% group_by(tid) %>% summarise(
date = min(date), # 交易日期
cust = min(cust), # 顧客 ID
age = min(age), # 顧客 年齡級別
area = min(area), # 顧客 居住區別
items = n(), # 交易項目(總)數
pieces = sum(qty), # 產品(總)件數
total = sum(price), # 交易(總)金額
gross = sum(price - cost) # 毛利
) %>% data.frame
nrow(X) # 119422[1] 119422
# Check Quantile & Remove Outliers
sapply(X[,6:9], quantile, prob=c(.999, .9995, .9999)) items pieces total gross
99.9% 54 81.00 9009.6 1824.7
99.95% 62 94.29 10611.6 2179.8
99.99% 82 133.00 16044.4 3226.5
# Remove Outliers
X = subset(X, items<=62 & pieces<95 & total<10600) # 119297summary(X) tid date cust age
Min. : 1 Min. :2000-11-01 Length:119297 Length:119297
1st Qu.: 29855 1st Qu.:2000-11-29 Class :character Class :character
Median : 59702 Median :2001-01-01 Mode :character Mode :character
Mean : 59713 Mean :2000-12-31
3rd Qu.: 89586 3rd Qu.:2001-02-02
Max. :119422 Max. :2001-02-28
area items pieces total
Length:119297 Min. : 1.0 Min. : 1.00 Min. : 5
Class :character 1st Qu.: 2.0 1st Qu.: 3.00 1st Qu.: 227
Mode :character Median : 5.0 Median : 6.00 Median : 510
Mean : 6.8 Mean : 9.21 Mean : 849
3rd Qu.: 9.0 3rd Qu.:12.00 3rd Qu.: 1079
Max. :62.0 Max. :94.00 Max. :10534
gross
Min. :-1645
1st Qu.: 21
Median : 68
Mean : 130
3rd Qu.: 168
Max. : 2813
par(cex=0.8)
hist(X$date, "weeks", freq=T, las=2, main="No. Transaction per Week")
# 以12月最後一個禮拜的資料筆數最低不到2000筆,次低資料筆數是2月最後一個禮拜Ad0 = max(X$date) + 1 # 現在日期加 1
#以今天加1為基準看同顧客購買紀錄最小天數的距離&最大天數的距離
A = X %>% mutate(
days = as.integer(difftime(d0, date, units="days"))
) %>% group_by(cust) %>% summarise(
r = min(days), # recency 間隔最小天數
# 最近購買距今天數
# 選days裡面最小的
s = max(days), # seniority 最大間隔天數
# 第一次購買距今天數
# 選"天數"裡面最大的
f = n(), # frquency # 購買次數
m = mean(total), # monetary 貨幣 (平均花多少) # 平均購買金額
since = min(date), # 第一次購買日期 #看它的"日期""
rev = sum(total), # total revenue contribution 總收入貢獻
raw = sum(gross), # total gross profit contribution 總毛利貢獻
age = min(age), # age group
area = min(area), # area code
) %>% data.frame
nrow(A) # 32239[1] 32239
# difftime(time1, time2, tz,units = c(“auto”, “secs”, “mins”, “hours”,“days”, “weeks”))
# 單位= c(“自動”,“秒”,“分鐘”,“小時”,“天”,“週”))par(mfrow=c(1,2),cex=0.7)
table(A$age, useNA='ifany') %>% barplot(main="Age Groups",las=2)
table(A$area, useNA='ifany') %>% barplot(main="Areas",las=2) # 第一張圖可以看出來購買人數最多的年齡是分佈在35-39歲中
# 第二張圖可以看出來住在南港區的消費者是佔最多數的summary(A) cust r s f
Length:32239 Min. : 1.0 Min. : 1.0 Min. : 1.0
Class :character 1st Qu.: 9.0 1st Qu.: 56.0 1st Qu.: 1.0
Mode :character Median : 26.0 Median : 92.0 Median : 2.0
Mean : 37.5 Mean : 80.8 Mean : 3.7
3rd Qu.: 60.0 3rd Qu.:110.0 3rd Qu.: 4.0
Max. :120.0 Max. :120.0 Max. :85.0
m since rev raw
Min. : 8 Min. :2000-11-01 Min. : 8 Min. : -784
1st Qu.: 365 1st Qu.:2000-11-11 1st Qu.: 707 1st Qu.: 75
Median : 705 Median :2000-11-29 Median : 1749 Median : 241
Mean : 990 Mean :2000-12-10 Mean : 3140 Mean : 482
3rd Qu.: 1290 3rd Qu.:2001-01-04 3rd Qu.: 3964 3rd Qu.: 611
Max. :10532 Max. :2001-02-28 Max. :127686 Max. :20273
age area
Length:32239 Length:32239
Class :character Class :character
Mode :character Mode :character
par(mfrow=c(3,2), mar=c(3,3,4,2))
for(x in c('r','s','f','m'))
hist(A[,x],20,freq=T,main=x,xlab="",ylab="",cex.main=2)
hist(pmin(A$f,10),0:10,freq=T,xlab="",ylab="",cex.main=2,main="frequency")
# 跟10比取小;x軸範圍0到10
hist(log(A$m,10),freq=T,xlab="",ylab="",cex.main=2,main="log(money)")# cex.axis – 使用長度為 1 的數值指定刻度標籤數字/文本的大小。
# cex.lab – 使用長度為 1 的數值指定軸標籤文本的大小。
# cex.main – 使用長度為 1 的數值指定標題文本的大小。
# cex.sub – 使用長度為 1 的數值指定字幕標籤的大小
# r圖:大多數人最近的一筆訂單是在0-10天前發生
# s圖:大多數人的第一筆訂單是在距今100天到四個月前
# f圖:購買次數的分布圖,可以看出絕大多數的客人只有購買0-5次
# m圖:購買總額分布圖,購買總金額最多分布在0-1000元
# plim圖:一樣是購買次數分布圖,只是上限設在10次,所以可以看到在購買0-10次中大多數的人就只有買一次
# log圖:對購買總金額取對數過後的分布圖🌷 偏態分佈的處理方法
log(A$m, 10)pmin(A$f, 10)圖形與變數解析:
recency:最近購買距今天數。
s (seniority):高起來的地方,代表在當時吸收很多顧客。
frequency:顧客在限定時間內的購買次數。
log(money):money代表消費金額,或客單價。
商務數據分析中,上述的RFM為數據分析中最好的指標,我們可以透過RFM模型了解顧客的價值以及對企業的幫助。
is.na(Z) %>% colSums date cust age area cat prod qty cost price tid
0 0 0 0 0 0 0 0 0 0
is.na(X) %>% colSums tid date cust age area items pieces total gross
0 0 0 0 0 0 0 0 0
is.na(A) %>% colSums cust r s f m since rev raw age area
0 0 0 0 0 0 0 0 0 0
A0 = A; X0 = X; Z0 = Z
save(Z0, X0, A0, file="data/tf_final.rdata")# rm(list=ls(all=T))
# load("data/tf_final.rdata")
set.seed(111)
A0$grp = kmeans(scale(A0[,c(2:5,7,8)]),10)$cluster
table(A0$grp) # 族群大小
1 2 3 4 5 6 7 8 9 10
6379 35 1964 955 7859 347 1189 3622 2019 7870
# 把所有數值都拿去做分群了 ( ID、日期、年齡、地區不分 )在此我們用的是集群式分析k-means,將資料依照不同屬性將顧客做分群。 k-means分完群會把分群的向量放在”cluster”這個欄位裡面,用table(A$grp)看族群大小。
group_by(A0, grp) %>% summarise(
recent=mean(r),
freq=mean(f),
money=mean(m),
size=n() ) %>%
mutate( revenue = size*money/1000 ) %>%
filter(size > 1) %>%
ggplot(aes(x=freq, y=money)) +
geom_point(aes(size=revenue, col=recent),alpha=0.5) +
scale_size(range=c(4,30)) +
scale_color_gradient(low="green",high="red") +
scale_x_log10() + scale_y_log10(limits=c(300,3500)) +
geom_text(aes(label = size ),size=3) +
theme_bw() + guides(size=F) +
labs(title="Customer Segements(細分)",
subtitle="(bubble_size:revenue_contribution ; text:group_size)",
color="Recency") +
xlab("Frequency (log)") + ylab("Average Transaction(交易) Amount (log)")圖形解析:
將現有顧客分成十群,每個泡泡分別代表一群。
4種屬性,大小、顏色、X軸與Y軸可供判讀。
可以針對很常來買(頻率高),買很少(客單價低),去做行銷策略,擬定對這群顧客增加客單價的方法。
例如:以上面861人族群與下方3688族群比較,兩者都是營收貢獻大者,但861人的族群的營收貢獻,似乎還比3688族群高,代表雖然族群僅861人,但是他們每人的客單價很高,他們就是我們最重要的顧客!要是讓他們流失掉,會對公司營收造成很大的影響,因此要想盡辦法保留他們!
例如:再從7622族群看起,從x軸知道,他們購買的次數不多,從y軸來看,他們購買的金額也不高,但是這個族群有非常多人,我們可以運用行銷方式,增加他們的購買頻率,或是提高客單價,來提高這個族群的營收狀況。反觀上方的3688族群雖然購買次數與7622相似,但他們的客單價卻高很多。
因此,從這些泡泡圖,我們可以知道營收來源主要來自於哪裡。藉此來看出我們的行銷重點應該放在哪一些客群上。
第二集影片底加 (ctrl + click)
STS = c("N1","N2","R1","R2","S1","S2","S3")
Status = function(rx,fx,mx,sx,K) {factor(
ifelse(sx < 2*K,
ifelse(fx*mx > 50, "N2", "N1"),
ifelse(rx < 2*K,
ifelse(sx/fx < 0.75*K,"R2","R1"),
ifelse(rx < 3*K,"S1",
ifelse(rx < 4*K,"S2","S3")))), STS)}我們先依照三個參數(seniority, frequency, recency)把顧客分群,用ifelse條件式來將顧客區分新潛力顧客、新顧客、核心顧客、主力顧客、瞌睡顧客、半睡顧客、沉睡顧客。
圖三、顧客分群規則
K = as.integer(sum(A0$s[A0$f>1]) / sum(A0$f[A0$f>1])); K[1] 17
回購顧客的平均購買週期 K = 17 days
Y = list() # 建立一個空的LIST
D_hat = list(as.Date(paste0('2000-',c(11, 10),"-",c(30, 31))),
as.Date(paste0('2000-',c(12, 11),"-",c(31, 30))),
as.Date(paste0('2001-',c(1, 12),"-",c(31, 31))),
as.Date(paste0('2001-',c(2, 1),"-",c(28, 31))))
i = 0
for( y in c(11,12,1,2)) { # 每月月底將顧客資料彙整成一個資料框
i = i+1
D = D_hat[i] # 當期、前期的期末日期
Y[[paste0("M",y)]] = X0 %>% # 從交易資料(X:tid)做起
filter(date <= D[[1]][1]) %>% # 將資料切齊到期末日期
mutate(days = 1 + as.integer(D[[1]][1] - date)) %>% # 交易距期末天數
group_by(cust) %>% summarise( # 依顧客彙總 ...
recent = min(days), # 最後一次購買距期末天數
freq = n(), # 購買次數 (至期末為止)
money = mean(total), # 平均購買金額 (至期末為止)
senior = max(days), # 第一次購買距期末天數
status = Status(recent,freq,money,senior,K), # 期末狀態 (當期的分群)
since = min(date), # 第一次購買日期
age = first(age),
area = first(area),
y_freq = sum(date > D[[1]][2]), # 當期購買次數
y_revenue = sum(total[date > D[[1]][2]]) # 當期購買金額
) %>% data.frame
}head(Y$M11) # head可以檢視前六筆的資料 cust recent freq money senior status since age area y_freq
1 00001069 18 1 187.0 18 N2 2000-11-13 a99 z115 1
2 00001113 4 3 534.0 19 N2 2000-11-12 a99 z221 3
3 00001823 25 2 1087.0 29 N2 2000-11-02 a99 z114 2
4 00004381 13 1 701.0 13 N2 2000-11-18 a39 zOthers 1
5 00006668 6 2 652.5 20 N2 2000-11-11 a39 z115 2
6 00007795 2 1 3465.0 2 N2 2000-11-29 a39 zOthers 1
y_revenue
1 187
2 1602
3 2174
4 701
5 1305
6 3465
sapply(Y, nrow) # 透過sapply可以將清單的每一欄套入你指定的函數,並將結果整理以向量、矩陣、列表的形式輸出。 M11 M12 M1 M2
16742 23562 28579 32239
這邊我們可以看出每一月底的顧客族群人數
par(cex=0.8, mfrow=c(1,1))
cols = c("gold","orange","blue","green","pink","magenta","darkred") # 指定每個族群的顏色
sapply(Y, function(df) table(df$status)) %>% barplot(col=cols)
legend("topleft",rev(STS),fill=rev(cols)) # 拿來標示圖的圖例,並指定在左上角。+再使用直方圖繪出不同年份下的顧客分群 +要注意到的是:顧客可能在不同年份有不同的分群結果(動態)
我們先簡單看一下每一年不同顧客分群及其各特性的平均值。
CustSegments = do.call(rbind, lapply(Y, function(d) {
group_by(d, status) %>% summarise(
average_frequency = mean(freq),
average_amount = mean(money),
total_revenue = sum(y_revenue),
total_no_orders = sum(y_freq),
average_recency = mean(recent),
average_seniority = mean(senior),
group_size = n()
)})) %>% ungroup %>%
mutate(month_ = c(11,11,rep(12,6),rep(c(1,2), each=7))) %>% data.frame
head(CustSegments) status average_frequency average_amount total_revenue total_no_orders
1 N1 1.0695 28.569 16501 585
2 N2 1.9270 995.739 27285874 31208
3 N1 1.0583 24.765 5220 212
4 N2 1.3076 998.131 8446906 8839
5 R1 2.6367 957.222 5609439 6055
6 R2 7.2255 705.704 7295663 11585
average_recency average_seniority group_size month_
1 15.3327 16.302 547 11
2 11.6106 17.655 16195 11
3 18.7040 19.709 223 12
4 16.9577 19.917 7229 12
5 17.1261 49.524 5232 12
6 9.6824 52.219 3495 12
N2族群在減少(N1也微幅減少),要採取更大力度的新客專屬優惠活動以及會員制度的優惠來增加顧客忠誠度
改成中文欄位名稱
df = CustSegments %>% transmute(
`群組` = as.character(status), month_ = month_,
`平均購買次數` = average_frequency,
`平均客單價` = average_amount,
`總營收貢獻` = total_revenue
)
# mutate 和 transmute 函數將新變量添加到數據集。
# https://statisticsglobe.com/r-mutate-transmute-functions-dplyr-package# factor(df$month_,levels=c('11','12','1','2'))
ggplot(df, aes(
x=`平均購買次數`,y=`平均客單價`,color=`群組`,group=`群組`,ids=month_)) +
geom_point(aes(size=`總營收貢獻`,frame=factor(df$month_,levels=c('11','12','1','2'))),alpha=0.8) +
scale_size(range=c(2,12))-> g
ggplotly(g)filter(df,`群組`%in%c('N1','N2','R1','R2','S1','S2','S3')) %>%
ggplot(aes(
x=`平均購買次數`,y=`平均客單價`,color=`群組`,group=`群組`,ids=month_)) +
geom_path(alpha=0.5,size=2) +
geom_point(aes(size=`總營收貢獻`),alpha=0.8) +
scale_size(range=c(2,12)) -> g
ggplotly(g)df = merge(Y$M1[,c(1,6)], Y$M2[,c(1,6)],
by="cust", all.x=T)
tx = table(df$status.x, df$status.y) %>%
as.data.frame.matrix() %>% as.matrix()
tx # 流量矩陣(選擇1月和2月最後兩月的分群結果做流量分析) N1 N2 R1 R2 S1 S2 S3
N1 4 0 8 2 28 14 0
N2 0 574 1324 310 2429 906 0
R1 0 0 5319 374 2314 647 0
R2 0 0 420 2458 234 40 0
S1 0 0 1190 51 0 644 1336
S2 0 0 1342 12 0 0 2713
S3 0 0 1008 0 0 0 2878
我們可以想像今年被判斷是主力顧客的顧客明年可能會變成瞌睡顧客,所以把每兩年的顧客分群結果做流量矩陣來看出數量上的變化
tx %>% prop.table(1) %>% round(3) # 流量矩陣(%) N1 N2 R1 R2 S1 S2 S3
N1 0.071 0.000 0.143 0.036 0.500 0.250 0.000
N2 0.000 0.104 0.239 0.056 0.438 0.163 0.000
R1 0.000 0.000 0.615 0.043 0.267 0.075 0.000
R2 0.000 0.000 0.133 0.780 0.074 0.013 0.000
S1 0.000 0.000 0.369 0.016 0.000 0.200 0.415
S2 0.000 0.000 0.330 0.003 0.000 0.000 0.667
S3 0.000 0.000 0.259 0.000 0.000 0.000 0.741
或者是看出百分比的變化。
可以多注重N跟R族群,因為是我們的主力客群
+R1:有六成會在下一期繼續留在R1,但是也有將近三成會,但是也有將近三成會變成瞌睡客戶,所以需要利用會員專屬活動或優惠來增強此族群的忠誠度 +R2:算是相對穩定的主力(VIP)客戶,有將近八成都會繼續成為tafeng的R2客群 +N1:N1有一半都會變成瞌睡客戶,因此要提供更多新客優惠活動來養成客戶來tafeng消費的習慣 +N2:有兩成會成會R1主力客戶,但仍然有超過四成會成為瞌睡客戶。N2是最有潛力發展為R2客群的,所以應該要提供更專屬的會員制度以及專屬活動優惠來養成消費習慣以及提高忠誠度
chorddiag(tx, groupColors=cols)利用chorddiag來將剛剛流量變化的結果視覺化。
在這個案例裡面,我們的資料是收到M2月底,所以我們可以假設現在的時間是M2月底,我們想要用現有的資料建立模型,來預測每一位顧客:
但是,我們並沒有M3的資料,為了要建立模型,我們需要先把時間回推一期,也就是說:
假如M3的情況(跟M2比)沒有太大的變化的話,接下來我們就可以
我們用M1年底的資料做自變數,M2年的資料做應變數
CX = left_join(Y$M1, Y$M2[,c(1,10,11)], by="cust") # 用顧客id來將2月的實際結果合併至1月的資料來做預測
head(CX) cust recent freq money senior status since age area y_freq.x
1 00001069 11 2 579.0 80 R1 2000-11-13 a99 z115 0
2 00001113 26 4 557.5 81 R1 2000-11-12 a99 z221 0
3 00001359 59 1 364.0 59 S2 2000-12-04 a99 zOthers 0
4 00001823 8 3 869.0 91 R1 2000-11-02 a99 z114 0
5 00002189 29 2 7028.0 61 R1 2000-12-02 a99 z106 0
6 00003667 37 2 2379.5 55 S1 2000-12-08 a99 zOthers 0
y_revenue.x y_freq.y y_revenue.y
1 0 2 786
2 0 0 0
3 0 0 0
4 0 0 0
5 0 0 0
6 0 2 1570
names(CX)[10:13] = c("freq0","revenue0","Retain", "Revenue") # 把2月的實際結果改名為保留/收益
CX$Retain = CX$Retain > 0
head(CX) cust recent freq money senior status since age area freq0
1 00001069 11 2 579.0 80 R1 2000-11-13 a99 z115 0
2 00001113 26 4 557.5 81 R1 2000-11-12 a99 z221 0
3 00001359 59 1 364.0 59 S2 2000-12-04 a99 zOthers 0
4 00001823 8 3 869.0 91 R1 2000-11-02 a99 z114 0
5 00002189 29 2 7028.0 61 R1 2000-12-02 a99 z106 0
6 00003667 37 2 2379.5 55 S1 2000-12-08 a99 zOthers 0
revenue0 Retain Revenue
1 0 TRUE 786
2 0 FALSE 0
3 0 FALSE 0
4 0 FALSE 0
5 0 FALSE 0
6 0 TRUE 1570
table(CX$Retain) %>% prop.table() # 平均保留機率 = 46.321%
FALSE TRUE
0.53679 0.46321
set.seed(2022)
spl = sample.split(CX$Retain, SplitRatio=0.7) # 回傳 TRUE & FALSE
c(nrow(CX), sum(spl), sum(!spl))[1] 28579 20006 8573
# Logistic:預測下次會來嗎;訓練集7成、測試(驗證)集3成cbind(CX, spl) %>% filter(Retain) %>%
ggplot(aes(x=log(money))) + geom_density(aes(fill=spl), alpha=0.5)# 利用抓出會來買的,然後用 density 看訓練集跟測試集分布
# sample.split 會幫你挑出好切割處# 只對有來購買的人做模型
dx = subset(CX, Revenue > 0) %>% mutate_at(c('revenue0','money','Revenue'), log10)
n = nrow(dx) # 13238 人會來
set.seed(2022)
spl2 = sample.split(dx$money, SplitRatio=0.7)
c(nrow(dx), sum(spl2), sum(!spl2)) # 13238 9266 3972[1] 13238 9266 3972
cbind(dx, spl2) %>%
ggplot(aes(x=money)) + geom_density(aes(fill=spl2), alpha=0.5)# c('revenue0','money','Revenue') 取 log10 好觀察金錢數據
# 簡單線性回歸:預測下次來買了多少;訓練集7成、測試(驗證)集3成
# 有消費==目標月份會來
# 13238 人會來TR = subset(CX, spl) # 訓練集
TS = subset(CX, !spl) # 測試集mRet0 = glm(Retain ~ ., TR[,c(2:6,8:12)], family=binomial()) # 利用邏輯式回歸來預測顧客是否會購買
summary(mRet0)
Call:
glm(formula = Retain ~ ., family = binomial(), data = TR[, c(2:6,
8:12)])
Deviance Residuals:
Min 1Q Median 3Q Max
-3.895 -0.873 -0.700 1.032 1.915
Coefficients: (2 not defined because of singularities)
Estimate Std. Error z value Pr(>|z|)
(Intercept) -1.8053689 0.4137411 -4.36 0.0000128 ***
recent -0.0105095 0.0022435 -4.68 0.0000028 ***
freq 0.3130961 0.0176426 17.75 < 0.0000000000000002 ***
money -0.0000430 0.0000169 -2.55 0.0108 *
senior 0.0065831 0.0015571 4.23 0.0000236 ***
statusN2 0.4491058 0.3983262 1.13 0.2595
statusR1 0.6290772 0.4038690 1.56 0.1193
statusR2 0.6085693 0.4126343 1.47 0.1403
statusS1 0.5809723 0.4045987 1.44 0.1510
statusS2 0.6187092 0.4100433 1.51 0.1313
statusS3 0.5044697 0.4215869 1.20 0.2315
agea29 -0.0106011 0.0876134 -0.12 0.9037
agea34 0.0801872 0.0807650 0.99 0.3208
agea39 0.1057536 0.0800603 1.32 0.1865
agea44 0.0750293 0.0820526 0.91 0.3605
agea49 0.0994172 0.0852718 1.17 0.2437
agea54 0.0786963 0.0938188 0.84 0.4016
agea59 0.1985533 0.1106036 1.80 0.0726 .
agea64 0.1379957 0.1186862 1.16 0.2450
agea69 0.2682386 0.1051167 2.55 0.0107 *
agea99 -0.1053341 0.1493492 -0.71 0.4806
areaz106 0.0265156 0.1341510 0.20 0.8433
areaz110 -0.1429280 0.1051570 -1.36 0.1741
areaz114 0.1115177 0.1119236 1.00 0.3191
areaz115 0.3025018 0.0976362 3.10 0.0019 **
areaz221 0.1665119 0.0983496 1.69 0.0904 .
areazOthers -0.0351665 0.1052077 -0.33 0.7382
areazUnknown -0.0175280 0.1234464 -0.14 0.8871
freq0 NA NA NA NA
revenue0 NA NA NA NA
---
Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
(Dispersion parameter for binomial family taken to be 1)
Null deviance: 27626 on 20005 degrees of freedom
Residual deviance: 23172 on 19978 degrees of freedom
AIC: 23228
Number of Fisher Scoring iterations: 5
從預測的結果我們可以發現除了statusN2變數&年齡以外,大部分變數對預測模型都有顯著的解釋性
mRet = step(mRet0) Start: AIC=23228
Retain ~ recent + freq + money + senior + status + age + area +
freq0 + revenue0
Step: AIC=23228
Retain ~ recent + freq + money + senior + status + age + area +
freq0
Step: AIC=23228
Retain ~ recent + freq + money + senior + status + age + area
Df Deviance AIC
- age 10 23188 23224
- status 6 23183 23227
<none> 23172 23228
- money 1 23179 23233
- senior 1 23190 23244
- recent 1 23194 23248
- area 7 23261 23303
- freq 1 23565 23619
Step: AIC=23224
Retain ~ recent + freq + money + senior + status + area
Df Deviance AIC
- status 6 23199 23223
<none> 23188 23224
- money 1 23195 23229
- senior 1 23205 23239
- recent 1 23210 23244
- area 7 23278 23300
- freq 1 23579 23613
Step: AIC=23223
Retain ~ recent + freq + money + senior + area
Df Deviance AIC
<none> 23199 23223
- money 1 23206 23228
- area 7 23289 23299
- senior 1 23297 23319
- recent 1 23372 23394
- freq 1 23994 24016
summary(mRet)
Call:
glm(formula = Retain ~ recent + freq + money + senior + area,
family = binomial(), data = TR[, c(2:6, 8:12)])
Deviance Residuals:
Min 1Q Median 3Q Max
-3.860 -0.868 -0.708 1.036 1.886
Coefficients:
Estimate Std. Error z value Pr(>|z|)
(Intercept) -1.2339549 0.1034930 -11.92 <0.0000000000000002 ***
recent -0.0118456 0.0008959 -13.22 <0.0000000000000002 ***
freq 0.3092137 0.0134065 23.06 <0.0000000000000002 ***
money -0.0000450 0.0000166 -2.70 0.0069 **
senior 0.0090103 0.0009069 9.94 <0.0000000000000002 ***
areaz106 0.0262026 0.1339165 0.20 0.8449
areaz110 -0.1483408 0.1049108 -1.41 0.1574
areaz114 0.1002039 0.1116068 0.90 0.3693
areaz115 0.2934349 0.0973491 3.01 0.0026 **
areaz221 0.1560704 0.0980435 1.59 0.1114
areazOthers -0.0460155 0.1048805 -0.44 0.6608
areazUnknown -0.0584368 0.1214547 -0.48 0.6304
---
Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
(Dispersion parameter for binomial family taken to be 1)
Null deviance: 27626 on 20005 degrees of freedom
Residual deviance: 23199 on 19994 degrees of freedom
AIC: 23223
Number of Fisher Scoring iterations: 5
# 自動挑選變數,讓 AIC 下降
# AIC 越低,代表模型的配適度(goodness-of-fit)越佳
# AIC 下降 : 在一定容忍(誤差)下 精簡 & 準確 模型pred = predict(mRet,TS,type="response")
table(actual = TS$Retain, predict = pred>0.5) predict
actual FALSE TRUE
FALSE 3738 864
TRUE 1757 2214
# 混淆矩陣 (Confusion Matrix)
# 臨界機率 = 0.5table(actual = TS$Retain, predict = pred>0.5) %>%
{sum(diag(.))/sum(.)} # 臨界機率 = 0.5 時正確率(ACC): 69.427% [1] 0.69427
colAUC(pred,TS$Retain) # 辯識率(AUC): 74.802% [,1]
FALSE vs. TRUE 0.74802
prediction(pred, TS$Retain) %>% # ROC CURVE 面積:0.74802
performance("tpr", "fpr") %>%
plot(print.cutoffs.at=seq(0,1,0.1))圖五、邏輯式迴歸混淆矩陣
接著我們來預測會來購買的人會花費多少金額。 我們必須使用的是迴歸來預測數量。
# 只對有來購買的人做模型
dx = subset(CX, Revenue > 0) # 只對有來購買的人做模型
TR2 = subset(dx, spl2)
TS2 = subset(dx, !spl2)mRev0 = lm(log(Revenue) ~ recent + freq + log(1+money) + senior +
status + freq0 + log(1+revenue0) + age + area, TR2)
summary(mRev0) # 判定係數:R2 = 0.289
Call:
lm(formula = log(Revenue) ~ recent + freq + log(1 + money) +
senior + status + freq0 + log(1 + revenue0) + age + area,
data = TR2)
Residuals:
Min 1Q Median 3Q Max
-4.707 -0.521 0.108 0.641 3.845
Coefficients: (2 not defined because of singularities)
Estimate Std. Error t value Pr(>|t|)
(Intercept) 3.807706 0.356898 10.67 < 0.0000000000000002 ***
recent -0.001031 0.001390 -0.74 0.4584
freq 0.056702 0.003292 17.22 < 0.0000000000000002 ***
log(1 + money) 0.547579 0.011281 48.54 < 0.0000000000000002 ***
senior 0.000156 0.000842 0.18 0.8533
statusN2 -0.958110 0.346989 -2.76 0.0058 **
statusR1 -0.971055 0.349167 -2.78 0.0054 **
statusR2 -0.804698 0.350374 -2.30 0.0217 *
statusS1 -0.984620 0.350171 -2.81 0.0049 **
statusS2 -0.944934 0.353200 -2.68 0.0075 **
statusS3 -0.854638 0.359282 -2.38 0.0174 *
freq0 NA NA NA NA
log(1 + revenue0) NA NA NA NA
agea29 0.128268 0.057594 2.23 0.0260 *
agea34 0.227892 0.052898 4.31 0.00001663 ***
agea39 0.267827 0.052188 5.13 0.00000029 ***
agea44 0.250653 0.053189 4.71 0.00000248 ***
agea49 0.186992 0.055156 3.39 0.0007 ***
agea54 0.181062 0.060190 3.01 0.0026 **
agea59 0.165434 0.070492 2.35 0.0190 *
agea64 0.075700 0.074900 1.01 0.3122
agea69 -0.079652 0.065091 -1.22 0.2211
agea99 0.244216 0.091120 2.68 0.0074 **
areaz106 -0.019264 0.098294 -0.20 0.8446
areaz110 -0.003341 0.078318 -0.04 0.9660
areaz114 -0.121421 0.082124 -1.48 0.1393
areaz115 -0.096494 0.071474 -1.35 0.1770
areaz221 -0.061592 0.072068 -0.85 0.3928
areazOthers -0.070727 0.077636 -0.91 0.3623
areazUnknown -0.125468 0.086977 -1.44 0.1492
---
Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
Residual standard error: 0.972 on 9238 degrees of freedom
Multiple R-squared: 0.291, Adjusted R-squared: 0.289
F-statistic: 140 on 27 and 9238 DF, p-value: <0.0000000000000002
# 簡單線性回歸:預測下次來買了多少可以由R^2得知,整體模型解釋力不夠高,推斷可能是因為資料比數不夠多(月份太少?、時間序列資料) 但仍然可以看出除了statusN2 & 地區變數以外,其他變數對於模型解釋力高。
從上面可看出某些變數對模型具有顯著的解釋力,判定係數為 0.289。 判定係數為 0.289,相關係數還是有 0.5 多,勉強還行
mRev = step(mRev0)Start: AIC=-507.78
log(Revenue) ~ recent + freq + log(1 + money) + senior + status +
freq0 + log(1 + revenue0) + age + area
Step: AIC=-507.78
log(Revenue) ~ recent + freq + log(1 + money) + senior + status +
freq0 + age + area
Step: AIC=-507.78
log(Revenue) ~ recent + freq + log(1 + money) + senior + status +
age + area
Df Sum of Sq RSS AIC
- area 7 9 8728 -512
- senior 1 0 8719 -510
- recent 1 1 8720 -509
<none> 8719 -508
- status 6 35 8754 -483
- age 10 73 8792 -451
- freq 1 280 8999 -217
- log(1 + money) 1 2224 10943 1595
Step: AIC=-511.94
log(Revenue) ~ recent + freq + log(1 + money) + senior + status +
age
Df Sum of Sq RSS AIC
- senior 1 0 8728 -514
- recent 1 0 8729 -513
<none> 8728 -512
- status 6 34 8762 -488
- age 10 75 8803 -453
- freq 1 277 9005 -224
- log(1 + money) 1 2273 11001 1631
Step: AIC=-513.93
log(Revenue) ~ recent + freq + log(1 + money) + status + age
Df Sum of Sq RSS AIC
- recent 1 0 8729 -515
<none> 8728 -514
- status 6 34 8762 -490
- age 10 75 8803 -455
- freq 1 325 9053 -177
- log(1 + money) 1 2273 11001 1629
Step: AIC=-515.49
log(Revenue) ~ freq + log(1 + money) + status + age
Df Sum of Sq RSS AIC
<none> 8729 -515
- status 6 34 8763 -491
- age 10 74 8803 -457
- freq 1 340 9069 -163
- log(1 + money) 1 2280 11009 1633
summary(mRev) # 判定係數:R2 = 0.289
Call:
lm(formula = log(Revenue) ~ freq + log(1 + money) + status +
age, data = TR2)
Residuals:
Min 1Q Median 3Q Max
-4.736 -0.523 0.113 0.643 3.822
Coefficients:
Estimate Std. Error t value Pr(>|t|)
(Intercept) 3.67939 0.34825 10.57 < 0.0000000000000002 ***
freq 0.05667 0.00299 18.98 < 0.0000000000000002 ***
log(1 + money) 0.55087 0.01121 49.15 < 0.0000000000000002 ***
statusN2 -0.94334 0.34693 -2.72 0.00656 **
statusR1 -0.94773 0.34629 -2.74 0.00622 **
statusR2 -0.78056 0.34775 -2.24 0.02482 *
statusS1 -0.98833 0.34691 -2.85 0.00440 **
statusS2 -0.96474 0.34707 -2.78 0.00545 **
statusS3 -0.89260 0.34741 -2.57 0.01021 *
agea29 0.13227 0.05756 2.30 0.02159 *
agea34 0.23403 0.05282 4.43 0.00000950 ***
agea39 0.27535 0.05207 5.29 0.00000013 ***
agea44 0.25809 0.05310 4.86 0.00000119 ***
agea49 0.19228 0.05509 3.49 0.00049 ***
agea54 0.18705 0.06013 3.11 0.00187 **
agea59 0.16975 0.07046 2.41 0.01601 *
agea64 0.08037 0.07485 1.07 0.28298
agea69 -0.07171 0.06495 -1.10 0.26957
agea99 0.22229 0.08611 2.58 0.00985 **
---
Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
Residual standard error: 0.972 on 9247 degrees of freedom
Multiple R-squared: 0.29, Adjusted R-squared: 0.289
F-statistic: 210 on 18 and 9247 DF, p-value: <0.0000000000000002
# 自動挑選變數,讓 AIC 下降
# AIC 越低,代表模型的配適度(goodness-of-fit)越佳
# 發現變數變少還是有一樣的解釋力
# 判定係數:R2 = 0.289 不變
# AIC 下降 : 在一定容忍(誤差)下 精簡 & 準確 模型plot(log(TS2$Revenue), predict(mRev,TS2), col='pink', cex=0.65)
abline(0,1,col='red') r2.tr = summary(mRev)$r.sq
SST = sum((TS2$Revenue - mean(TR2$Revenue))^ 2)
SSE = sum((exp(predict(mRev, TS2)) - TS2$Revenue)^2)
r2.ts = 1 - (SSE/SST)
c(R2train=r2.tr, R2test=r2.ts)R2train R2test
0.29014 0.24714
# 訓練集跟測試集的 R^2
# 差距 0.043,看來是沒有過擬合的現象第三集影片底加 (ctrl + click)
使用模型對M2月底的資料做預測,對資料中的每一位顧客,預測她們在M3的保留率和購買金額。
CX = Y$M2
names(CX)[10:11] = c("freq0","revenue0")
# 預測M3保留率
CX$ProbRetain = predict(mRet,CX,type='response')
# 預測M3購買金額
CX$PredRevenue = exp(predict(mRev,CX))par(mfrow=c(1,2), mar=c(4,3,3,2), cex=0.8)
hist(CX$ProbRetain,main="ProbRetain", ylab="")
hist(log(CX$PredRevenue,10),main="log(PredRevenue)", ylab="")接著我們透過計算顧客終生價值讓我們了解每一個顧客的潛在價值有多大 。
\[ V_i = \sum_{t=0}^N g \times m_i \frac{r_i^t}{(1+d)^t} = g \times m_i \sum_{t=0}^N (\frac{r_i}{1+d})^t \]
N = 5 # 期數 = 5
d = 0.1 # 利率 = 10%估計毛利率 \(m\)
# load(data/tf0.rdata)
# Z0 %>% summarise(sum(price)/sum(cost) - 1)
margin = Z0 %>% summarise(sum(price)/sum(cost) - 1) # 0.18211
g = as.numeric(margin) # (稅前)獲利率 = 毛利率 = 0.18211
g[1] 0.18211
CX$CLV = g * CX$PredRevenue * rowSums(sapply(
0:N, function(i) (CX$ProbRetain/(1+d))^i ) )
summary(CX$CLV) Min. 1st Qu. Median Mean 3rd Qu. Max.
16 172 287 462 488 71852
par(mar=c(2,2,3,1), cex=0.8)
hist(log(CX$CLV,10), xlab="", ylab="")
# 整體 CLV 分布我們將結果彙整成表格,可以很直接的看到每一個族群的平均保留機率、期望營收貢獻以及終生價值,這有助於讓我們了解每個消費者狀態的性質並可以對其進行策略擬定。
# 各族群的平均營收貢獻、保留機率、終生價值
CX %>% group_by(status) %>% summarise_at(vars(ProbRetain:CLV), mean)# A tibble: 7 x 4
status ProbRetain PredRevenue CLV
<fct> <dbl> <dbl> <dbl>
1 N1 0.302 332. 83.3
2 N2 0.307 829. 209.
3 R1 0.673 982. 465.
4 R2 0.931 2145. 1740.
5 S1 0.426 934. 297.
6 S2 0.362 804. 229.
7 S3 0.277 881. 216.
# 回購 消費 CLV
# R2 0.93137 2145.17 1739.758
# N2 0.30676 829.38 209.233
# R1 0.67320 981.93 465.177 繪製顧客終生價值對顧客狀態分群的盒狀圖。
par(mar=c(3,3,4,2), cex=0.8)
boxplot(log(CLV,10)~status, CX, main="CLV by Groups")從互動式流量分析以及分群規則來看,我們可以知道各群顧客的移轉程度以及消費特性為何,再根據這些資料進行分析制定客製化的行銷策略,此外我們必須根據顧客終生價值去判斷哪些群的顧客是我們最需要做顧客保留的。
(策略不一定要跟下面寫的一樣~可以做為參考用!)
S族群:採用比較刺激的行銷策略喚醒此群顧客,但行銷主力並不在此。S1:瞌睡顧客,瞌睡顧客對於這家店的認識有一定時間,有一半的機會成為主力顧客,但也有另一半的機會成為半睡顧客,且極少數會仍保留於此狀態中,雖然CLV偏低,但若成流轉成為主力顧客仍有一定潛力存在,為了增加成為主力顧客的機會,我們利用e-mail行銷,針對此群顧客寄出老顧客的限時特惠商品或是折價券,吸引瞌睡顧客重新回到店裡消費,再加以利用會員制度讓顧客留住在店中。
S2:半睡顧客,此群顧客的CLV值低,且多數會流轉成為沈睡顧客,少數會變成瞌睡顧客,由於顧客保留價值低,故對於此群顧客我們採用不分群的行銷策略模式,利用特惠、週年慶、特賣的方式吸引顧客上門。
S3:沈睡顧客,此類顧客極難再轉為其他種類顧客,此群顧客價值低,保留所造成的效果也不明顯,故採用與S2一樣的不針對性做法,採用較消極的行銷方式。
R1:主力顧客:主力顧客的CLV為第三高,其比較容易流轉成瞌睡顧客,為了避免變成瞌睡顧客我們必須增強此群的忠誠度,像是設立一些會員分級獎勵制度,越高等級的顧客就能享有越多的尊爵會員優惠,並且每年贈送生日禮等等。藉此吸引主力顧客持續在店消費,降低成為瞌睡顧客的機會。
R2:核心顧客:核心顧客的CLV為最高,其也不太容易轉成其他群顧客,在會員至當中此群顧客最終會成為最高等級會員,以最高等級的會員優惠、無微不至的特別服務,讓核心顧客有美好的消費體驗,持續保留核心顧客。
N1:新顧客:新顧客屬於還在觀察、觀望的一族群,其消費貢獻不高,CLV極低,流轉為潛力顧客的機會也不高,但必須持續培養新顧客成為忠誠顧客,增加店的業績成長,故即使效益看似不高也必須做一些保留的行銷策略,可以利用一些充滿新鮮感的行銷方式像是集點好禮、現金回饋、新客好禮禮包分階段贈送的方式吸引其持續到店消費。
N2:新潛力顧客:此群顧客對店的收益貢獻相當高,CLV極高,有一定機會成為R2顧客,且有很大機會被保留於原來狀態,故要對此群顧客進行積極的顧客保留行銷方式,可進行新會員入會好禮,將新潛力顧客變成會員,對會員定期推出有趣、優惠的行銷活動,讓其更習慣於在這裡消費,也可以透過寄送e-mail的方式寄送新顧客的專屬優惠。
假設我們知道(不知道也可以假設)各項行銷工具的成本、和效果,模型可以幫助我們:
R1 N2族群為主R1族群的預測保留率和購買金額
par(mfrow=c(1,2), mar=c(4,3,3,2), cex=0.8)
hist(CX$ProbRetain[CX$status=="R1"],main="ProbRetain",xlab="")
hist(log(CX$PredRevenue[CX$status=="R1"],10),main="PredRevenue",xlab="")N2族群的預測保留率和購買金額
par(mfrow=c(1,2), mar=c(4,3,3,2), cex=0.8)
hist(CX$ProbRetain[CX$status=="N2"],main="ProbRetain",xlab="")
hist(log(CX$PredRevenue[CX$status=="N2"],10),main="PredRevenue",xlab="")先來假設一下行銷工具的成本和預期效益,假設有一個成本是10塊,可以將下一期的購買機率提高到0.5的行銷工具
# 顧客i預期營收增額 :
# delta Ri = 回購機率*預期營收(工具後) - 回購機率*預期營收(工具前)
#(effect*effect$PredRevenue - Target$ProbRetain*Target$PredRevenue)
# 顧客i預期獲利增額 :
# delta Xi = delta Ri * 利潤率(g)
# 顧客i預期(淨)報償 :
# pi = delta Xi - c
# 總預期(淨)報償
# sumation pi
# pi = (effect - Target$ProbRetain)還要再乘利潤率 * Target$PredRevenue - cost
# g : (稅前)獲利率
#######################################################################
# 回購 消費 CLV
# R2 0.93137 2145.17 1739.758
# N2 0.30676 829.38 209.233
# R1 0.67320 981.93 465.177
cost = 10 # 成本
effect = 0.5 # 效益:下一期的購買機率
# Target$PredRevenue 的變化量
effect_Rev = 1100 # 效益:下一期的購買金額再來估計這項行銷工具對每一位N2顧客的預期(淨)報酬,N2:主提高頻率(忠誠)
Target1 = subset(CX, status=="N2")
Target1$ExpReturn = (effect - Target1$ProbRetain)*g *Target1$PredRevenue - cost
summary(Target1$ExpReturn) Min. 1st Qu. Median Mean 3rd Qu. Max.
-93.03 4.86 15.48 20.28 30.76 163.00
行銷工具對每一位R1顧客的預期(淨)報酬,R1:主提高購買(客單價)
Target2 = subset(CX, status=="R1")
Target2$ExpReturn = Target2$ProbRetain*g *(effect_Rev - Target2$PredRevenue) - cost
summary(Target2$ExpReturn) Min. 1st Qu. Median Mean 3rd Qu. Max.
-368.91 -28.04 11.52 3.78 43.54 138.23
我們可以從N2挑出預期報酬很大的行銷對象
Target1 %>% arrange(desc(ExpReturn)) %>% select(cust, ExpReturn) %>% head(15) cust ExpReturn
1 01606799 163.00
2 00019125 154.96
3 01697933 146.36
4 02178578 137.89
5 01763423 137.41
6 01968446 134.96
7 01736137 133.68
8 01867190 133.08
9 01768787 132.00
10 01628579 128.26
11 01443066 125.34
12 01770599 122.98
13 01214123 118.10
14 02068794 115.07
15 01127331 115.07
# 針對性,如果真的可以針對(選)顧客的話
# 如果幾乎都是負數的話 : 平均而言,不做sum(Target1$ExpReturn > 0) # 可實施對象:3554[1] 3554
在N2之中,有3554人的預期報酬大於零,如果對這3554人使用這項工具,我們的期望報酬是:
sum(Target1$ExpReturn[Target1$ExpReturn > 0]) # 預期報酬:86533[1] 86533
我們可以從R1挑出預期報酬很大的行銷對象
Target2 %>% arrange(desc(ExpReturn)) %>% select(cust, ExpReturn) %>% head(15) cust ExpReturn
1 00559720 138.23
2 01604788 136.67
3 01937138 136.33
4 01159219 133.24
5 01822090 130.73
6 01937107 129.11
7 02075853 129.08
8 01213522 128.46
9 01126396 127.70
10 01900460 126.80
11 00081252 126.44
12 00303873 124.55
13 01826333 124.23
14 01928938 123.96
15 01532616 123.96
# 針對性,如果真的可以針對(選)顧客的話sum(Target2$ExpReturn > 0) # 可實施對象:6205[1] 6205
在R1之中,有6205人的預期報酬大於零,如果對這6205人使用這項工具,我們的期望報酬是:
sum(Target2$ExpReturn[Target2$ExpReturn > 0]) # 預期報酬:258622[1] 258622
我們可以算出對所有的族群實施這項工具的期望報酬 …
Target1 = CX
Target1$ExpReturn = (effect - Target1$ProbRetain)* g *Target1$PredRevenue - cost
filter(Target1, Target1$ExpReturn > 0) %>%
group_by(status) %>% summarise(
No.Target = n(),
AvgROI = mean(ExpReturn),
TotalROI = sum(ExpReturn) ) %>% data.frame status No.Target AvgROI TotalROI
1 N1 93 3.593 334.145
2 N2 3554 24.348 86533.005
3 R1 653 12.345 8061.306
4 R2 6 11.325 67.947
5 S1 2661 26.392 70228.498
6 S2 1491 23.241 34652.305
7 S3 6064 31.678 192093.865
# S3 : 192093.865 最好,不過我們的 N2 : 86533.005,也不錯我們可以算出對所有的族群實施這項工具的期望報酬 …
Target2 = CX
Target2$ExpReturn = Target2$ProbRetain*g *(effect_Rev - Target2$PredRevenue) - cost
filter(Target2, Target2$ExpReturn > 0) %>%
group_by(status) %>% summarise(
No.Target = n(),
AvgROI = mean(ExpReturn),
TotalROI = sum(ExpReturn) ) %>% data.frame status No.Target AvgROI TotalROI
1 N1 134 32.412 4343.3
2 N2 2632 20.987 55238.2
3 R1 6205 41.680 258621.7
4 R2 676 37.520 25363.7
5 S1 2892 27.091 78347.1
6 S2 1510 26.279 39681.9
7 S3 4034 18.834 75975.9
# R1 : 258621.7 最好max(Target1$ExpReturn[Target1$status=='N2']) # 163[1] 163
min(Target1$ExpReturn[Target1$status=='N2']) # -93.03[1] -93.03
max(Target1$ExpReturn[Target1$status=='R1']) # 77.043[1] 77.043
min(Target1$ExpReturn[Target1$status=='R1']) # -246.65[1] -246.65
par(mfrow=c(2,1), mar=c(4,3,3,2), cex=0.8)
for(s in c('N2',"R1")) {
hist(Target1$ExpReturn[Target1$status==s], xlim=c(-220, 215), breaks=seq(-1000,1000,10),
ylim=c(0, 1500), main=s, xlab="exp.profit")
abline(v=0, col='green', lty=2)}max(Target2$ExpReturn[Target2$status=='N2']) # 82.603[1] 82.603
min(Target2$ExpReturn[Target2$status=='N2']) # -133.58[1] -133.58
max(Target2$ExpReturn[Target2$status=='R1']) # 138.23[1] 138.23
min(Target2$ExpReturn[Target2$status=='R1']) # -368.91[1] -368.91
par(mfrow=c(2,1), mar=c(4,3,3,2), cex=0.8)
for(s in c('N2',"R1")) {
hist(Target2$ExpReturn[Target2$status==s], xlim=c(-220, 150), breaks=seq(-1000,1000,10),
ylim=c(0, 1500), main=s, xlab="exp.profit")
abline(v=0, col='green', lty=2)}save(CX, file="data/CX0.rdata")rm(list=ls(all=T))
load("data/CX0.rdata")# S 曲線
DP = function(x,m0,b0,a0) {m0*plogis((10/a0)*(x-b0))}
mm=c(0.65, 0.7, 0.46, 0.5)
bb=c( 38, 75,15, 35)
aa=c( 30, 45,20, 10)
X = seq(0,100,2)
do.call(rbind, lapply(1:length(mm), function(i) data.frame(
Inst=paste0('Inst',i), Cost=X,
Gain=DP(X,mm[i],bb[i],aa[i])
))) %>% data.frame %>%
ggplot(aes(x=Cost, y=Gain, col=Inst)) +
geom_line(size=1.5,alpha=0.5) + theme_bw() +
ggtitle("Prob. Function: f(x|m,b,a)")估計毛利率 \(m\)
load('data/tf0.rdata')
# Z0 %>% summarise(sum(price)/sum(cost) - 1)
margin = as.numeric(Z0 %>% summarise(sum(price)/sum(cost) - 1)) # 0.18211
g = as.numeric(margin) # (稅前)獲利率 = 毛利率 = 0.18211
g[1] 0.18211
X = seq(0, 100, 2) # 成本範圍
# 四個企劃都只針對兩客群做
ci = sapply(
list(c("N2","R1"),c("N2","R1"),c("N2","R1"),c("N2","R1")),
function(v) CX$status %in% v)
# 這裡有 4 個模擬器,分別看
# eReturn : 對所有的人行銷的總預期收益
# eReturn2 : 只對期收益大於零的人做行銷的總預期收益
# N : 預期收益大於零的人數
# 再用 lapply rbind 4 個模擬器
df = do.call(rbind, lapply(1:length(mm), function(i) {
sapply(X, function(x) {
dp = pmin(1- CX$ProbRetain[ ci[,i] ] , DP(x,mm[i],bb[i],aa[i]))
eR = dp* CX$PredRevenue[ ci[,i] ] *margin - x
c(i=i, x=x, eR.ALL=sum(eR), N=sum(eR>0), eR.SEL=sum(eR[eR > 0]) )
}) %>% t %>% data.frame
}))
# vars :選擇變量 == select()
df %>%
mutate_at(vars(eR.ALL, eR.SEL), function(y) round(y/1000)) %>%
gather('key','value',-i,-x) %>%
mutate(Instrument = paste0('I',i)) %>%
ggplot(aes(x=x, y=value, col=Instrument)) +
geom_hline(yintercept=0, linetype='dashed', col='blue') +
geom_line(size=1.5,alpha=0.5) +
xlab('工具選項(成本)') + ylab('預期收益($K)') +
ggtitle('行銷工具優化','假設行銷工具的效果是其成本的函數') +
facet_wrap(~key,ncol=1,scales='free_y') + theme_bw() -> p
plotly::ggplotly(p)# eR.ALL=sum(eR),全做通常都會虧本
# eR.SEL : 挑正的做 : Inst3:菜籃分析 : 成本:20
# 預期(淨)營收 : 542249
# N : 20元時,可對 13066 個人做
# Inst3:菜籃分析 : 成本:20;對13066人做;報酬:542249# 利用這行指令,抓出所有模擬器的最佳解 : eR.SEL 最大 (挑正的做)
group_by(df, i) %>% top_n(1,eR.SEL)# A tibble: 4 x 5
# Groups: i [4]
i x eR.ALL N eR.SEL
<dbl> <dbl> <dbl> <dbl> <dbl>
1 1 46 306709. 8892 410340.
2 2 86 -260509. 4107 178697.
3 3 20 532937. 13066 542249.
4 4 38 322013. 9776 388942.
# Inst3:菜籃分析 : 成本:20;對13066人做;報酬:542249# 考慮距離 分別挑出目標客群
# Inst1:新品發表會 針對 南港、汐止顧客做
# Inst2:慈善義賣會 針對 南港、汐止顧客做
# Inst3:菜籃分析 針對 南港、汐止顧客做 成本:22 對14988人 報酬:619035 WIN!!
# Inst4:快閃 針對 南港、汐止顧客做
ci = sapply(
list(c("z115","z221"),c("z115","z221"),c("z115","z221"),c("z115","z221")),
function(v) CX$area %in% v)
X = seq(0, 100, 2)
df = do.call(rbind, lapply(1:length(mm), function(i) {
sapply(X, function(x) {
dp = pmin(1- CX$ProbRetain[ ci[,i] ] , DP(x,mm[i],bb[i],aa[i]))
eR = dp* CX$PredRevenue[ ci[,i] ] *margin - x
c(i=i, x=x, eR.ALL=sum(eR), N=sum(eR>0), eR.SEL=sum(eR[eR > 0]) )
}) %>% t %>% data.frame
}))
group_by(df, i) %>% top_n(1,eR.SEL)# A tibble: 4 x 5
# Groups: i [4]
i x eR.ALL N eR.SEL
<dbl> <dbl> <dbl> <dbl> <dbl>
1 1 46 300699. 10655 499253.
2 2 88 -461948. 4953 226840.
3 3 22 571277. 14988 619035.
4 4 40 291808. 11211 449620.
# 考慮距離 分別挑出目標客群
# Inst1:新品發表會 針對 30-44歲顧客做
# Inst2:慈善義賣會 針對 30-44歲顧客做
# Inst3:菜籃分析 針對 30-44歲顧客做 成本:22;對15208人;報酬:793658 Win!!
# Inst4:快閃 針對 30-44歲顧客做
ci = sapply(
list(c("a34","a39",'a44'),c("a34","a39",'a44'),c("a34","a39",'a44'),c("a34","a39",'a44')),
function(v) CX$age %in% v)
X = seq(0, 100, 2)
df = do.call(rbind, lapply(1:length(mm), function(i) {
sapply(X, function(x) {
dp = pmin(1- CX$ProbRetain[ ci[,i] ] , DP(x,mm[i],bb[i],aa[i]))
eR = dp* CX$PredRevenue[ ci[,i] ] *margin - x
c(i=i, x=x, eR.ALL=sum(eR), N=sum(eR>0), eR.SEL=sum(eR[eR > 0]) )
}) %>% t %>% data.frame
}))
group_by(df, i) %>% top_n(1,eR.SEL)# A tibble: 4 x 5
# Groups: i [4]
i x eR.ALL N eR.SEL
<dbl> <dbl> <dbl> <dbl> <dbl>
1 1 48 603272. 12135 725090.
2 2 88 -54630. 7051 386501.
3 3 22 767657. 15208 793658.
4 4 40 542916. 12665 632299.
我們可以算出對所有的族群實施這項工具的期望報酬 …
DP1 = DP(38,0.65,38,30) # 1 cost 取 b (中間)
cost1 = 38
Target3 = CX
Target3$ExpReturn = DP1* Target3$PredRevenue * g - cost1
filter(Target3, Target3$ExpReturn > 0) %>%
group_by(status) %>% summarise(
No.Target = n(),
AvgROI = mean(ExpReturn),
TotalROI = sum(ExpReturn) ) %>% data.frame status No.Target AvgROI TotalROI
1 N2 2468 26.640 65747
2 R1 7964 30.341 241632
3 R2 3078 92.990 286224
4 S1 3463 30.241 104725
5 S2 1284 27.042 34721
6 S3 4353 30.599 133196
# No.Target AvgROI TotalROI
# R1 7964 30.341 241632
# R2 3078 92.990 286224
# R1、R2值得發展par(mfrow=c(3,2), mar=c(4,3,3,2), cex=0.8)
for(s in c('N2',"R1",'S1','S2','S3')) {
hist(Target3$ExpReturn[Target3$status==s], xlim=c(-100, 150), breaks=seq(-1000,1000,10),
ylim=c(0, 1800), main=s, xlab="exp.profit")
abline(v=0, col='green', lty=2)}DP2 = DP(75,0.7,75,45) # 2 cost 取 b
cost2 = 75
Target3 = CX
Target3$ExpReturn = DP2* Target3$PredRevenue * g - cost2
filter(Target3, Target3$ExpReturn > 0) %>%
group_by(status) %>% summarise(
No.Target = n(),
AvgROI = mean(ExpReturn),
TotalROI = sum(ExpReturn) ) %>% data.frame status No.Target AvgROI TotalROI
1 N2 806 22.836 18406
2 R1 3167 23.669 74959
3 R2 2273 94.803 215487
4 S1 1341 24.597 32984
5 S2 425 23.721 10081
6 S3 1649 27.507 45359
# R2 : 215487 獨大;R1第二不錯par(mfrow=c(3,2), mar=c(4,3,3,2), cex=0.8)
for(s in c('N2',"R1",'S1','S2','S3')) {
hist(Target3$ExpReturn[Target3$status==s], xlim=c(-100, 150), breaks=seq(-1000,1000,10),
ylim=c(0, 1800), main=s, xlab="exp.profit")
abline(v=0, col='green', lty=2)}DP3 = DP(15,0.46,15,20) # 3 cost 取 b
cost3 = 15
Target3 = CX
Target3$ExpReturn = DP3* Target3$PredRevenue * g - cost3
filter(Target3, Target3$ExpReturn > 0) %>%
group_by(status) %>% summarise(
No.Target = n(),
AvgROI = mean(ExpReturn),
TotalROI = sum(ExpReturn) ) %>% data.frame status No.Target AvgROI TotalROI
1 N1 34 2.155 73.271
2 N2 3611 22.902 82698.226
3 R1 10041 27.822 279363.559
4 R2 3201 74.996 240063.295
5 S1 4591 26.648 122341.160
6 S2 1901 22.944 43616.141
7 S3 6034 25.892 156231.302
# No.Target AvgROI TotalROI
# R1 10041 27.822 279363.559
# R2 3201 74.996 240063.295
# R1 贏了!!par(mfrow=c(3,2), mar=c(4,3,3,2), cex=0.8)
for(s in c('N2',"R1",'S1','S2','S3')) {
hist(Target3$ExpReturn[Target3$status==s], xlim=c(-100, 150), breaks=seq(-1000,1000,10),
ylim=c(0, 1800), main=s, xlab="exp.profit")
abline(v=0, col='green', lty=2)}DP4 = DP(35,0.5,35,10) # 4 cost 取 b
cost4 = 35
Target3 = CX
Target3$ExpReturn = DP4* Target3$PredRevenue * g - cost4
filter(Target3, Target3$ExpReturn > 0) %>%
group_by(status) %>% summarise(
No.Target = n(),
AvgROI = mean(ExpReturn),
TotalROI = sum(ExpReturn) ) %>% data.frame status No.Target AvgROI TotalROI
1 N2 1965 19.261 37848
2 R1 6744 21.261 143382
3 R2 2948 68.782 202770
4 S1 2899 21.453 62193
5 S2 1009 19.948 20127
6 S3 3567 22.322 79621
# No.Target AvgROI TotalROI
# R1 6744 21.261 143382
# R2 2948 68.782 202770
# R2 : 最大;R1也不錯par(mfrow=c(3,2), mar=c(4,3,3,2), cex=0.8)
for(s in c('N2',"R1",'S1','S2','S3')) {
hist(Target3$ExpReturn[Target3$status==s], xlim=c(-100, 150), breaks=seq(-1000,1000,10),
ylim=c(0, 1800), main=s, xlab="exp.profit")
abline(v=0, col='green', lty=2)}如果你只有顧客ID、交易日期、交易金額三個欄位的話,你可以做的分析包括:
一般而言,這一些分析的結果,足夠讓我們制定顧客發展和顧客保留策略;至於顧客吸收策略,我們通常還需要從CRM撈出顧客個人屬性資料才能做到。